home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
c
/
structure.c
< prev
next >
Wrap
C/C++ Source or Header
|
1987-06-04
|
6KB
|
249 lines
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
structure.c
structure interface
*/
#include "include.h"
object siSstructure_print_function;
object siSstructure_slot_descriptions;
object siSstructure_include;
bool
structure_subtypep(x, y)
object x, y;
{
do {
if (type_of(x) != t_symbol)
return(FALSE);
if (x == y)
return(TRUE);
x = get(x, siSstructure_include, Cnil);
} while (x != Cnil);
return(FALSE);
}
object
structure_ref(x, name, n)
object x, name;
int n;
{
int i;
if (type_of(x) != t_structure ||
!structure_subtypep(x->str.str_name, name))
FEwrong_type_argument(name, x);
return(x->str.str_self[n]);
}
object
structure_set(x, name, n, v)
object x, name, v;
int n;
{
int i;
if (type_of(x) != t_structure ||
!structure_subtypep(x->str.str_name, name))
FEwrong_type_argument(name, x);
x->str.str_self[n] = v;
return(v);
}
object
structure_to_list(x)
object x;
{
object *p, s;
int i, n;
s = getf(x->str.str_name->s.s_plist,
siSstructure_slot_descriptions, Cnil);
vs_push(x->str.str_name);
vs_push(Cnil);
p = &vs_head;
for (i=0, n=x->str.str_length; !endp(s)&&i<n; s=s->c.c_cdr, i++) {
*p = make_cons(car(s->c.c_car), Cnil);
p = &((*p)->c.c_cdr);
*p = make_cons(x->str.str_self[i], Cnil);
p = &((*p)->c.c_cdr);
}
stack_cons();
return(vs_pop);
}
siLmake_structure()
{
object x;
int narg, i;
if ((narg = vs_top - vs_base) == 0)
too_few_arguments();
x = alloc_object(t_structure);
x->str.str_name = vs_base[0];
x->str.str_self = NULL;
x->str.str_length = --narg;
vs_base[0] = x;
x->str.str_self = (object *)alloc_relblock(sizeof(object)*narg);
vs_top = vs_base+1;
for (i = 0; i < narg; i++)
x->str.str_self[i] = vs_top[i];
}
siLcopy_structure()
{
object x, y;
int i, j;
check_arg(2);
x = vs_base[0];
if (type_of(x) != t_structure || x->str.str_name != vs_base[1])
FEwrong_type_argument(vs_base[1], x);
vs_base[1] = y = alloc_object(t_structure);
y->str.str_name = x->str.str_name;
y->str.str_self = NULL;
y->str.str_length = j = x->str.str_length;
y->str.str_self = (object *)alloc_relblock(sizeof(object)*j);
for (i = 0; i < j; i++)
y->str.str_self[i] = x->str.str_self[i];
vs_base++;
}
siLstructure_name()
{
check_arg(1);
if (type_of(vs_base[0]) != t_structure)
FEwrong_type_argument(Sstructure, vs_base[0]);
vs_base[0] = vs_base[0]->str.str_name;
}
siLstructure_ref()
{
object x;
int i;
check_arg(3);
x = vs_base[0];
if (type_of(x) != t_structure ||
!structure_subtypep(x->str.str_name, vs_base[1]))
FEwrong_type_argument(vs_base[1], x);
/*
if (type_of(vs_base[2]) != t_fixnum ||
(i = fix(vs_base[2])) < 0 || i >= x->str.str_length)
FEerror("~S is an illegal structure index.", 1, vs_base[2]);
*/
i = fix(vs_base[2]);
vs_base[0] = x->str.str_self[i];
vs_top = vs_base+1;
}
siLstructure_set()
{
object x;
int i;
check_arg(4);
x = vs_base[0];
if (type_of(x) != t_structure ||
!structure_subtypep(x->str.str_name, vs_base[1]))
FEwrong_type_argument(vs_base[1], x);
/*
if (type_of(vs_base[2]) != t_fixnum ||
(i = fix(vs_base[2])) >= x->str.str_length)
FEerror("~S is an illegal structure index.", 1, vs_base[2]);
*/
i = fix(vs_base[2]);
x->str.str_self[i] = vs_base[3];
vs_base = vs_top-1;
}
siLstructurep()
{
check_arg(1);
if (type_of(vs_base[0]) == t_structure)
vs_base[0] = Ct;
else
vs_base[0] = Cnil;
}
siLrplaca_nthcdr()
{
/*
Used in DEFSETF forms generated by DEFSTRUCT.
(si:rplaca-nthcdr x i v) is equivalent to
(progn (rplaca (nthcdr i x) v) v).
*/
int i;
object l;
check_arg(3);
if (type_of(vs_base[1]) != t_fixnum || fix(vs_base[1]) < 0)
FEerror("~S is not a non-negative fixnum.", 1, vs_base[1]);
if (type_of(vs_base[0]) != t_cons)
FEerror("~S is not a cons.", 1, vs_base[0]);
for (i = fix(vs_base[1]), l = vs_base[0]; i > 0; --i) {
l = l->c.c_cdr;
if (endp(l))
FEerror("The offset ~S is too big.", 1, vs_base[1]);
}
take_care(vs_base[2]);
l->c.c_car = vs_base[2];
vs_base = vs_base + 2;
}
siLlist_nth()
{
/*
Used in structure access functions generated by DEFSTRUCT.
si:list-nth is similar to nth except that
(si:list-nth i x) is error if the length of the list x is less than i.
*/
int i;
object l;
check_arg(2);
if (type_of(vs_base[0]) != t_fixnum || fix(vs_base[0]) < 0)
FEerror("~S is not a non-negative fixnum.", 1, vs_base[0]);
if (type_of(vs_base[1]) != t_cons)
FEerror("~S is not a cons.", 1, vs_base[1]);
for (i = fix(vs_base[0]), l = vs_base[1]; i > 0; --i) {
l = l->c.c_cdr;
if (endp(l))
FEerror("The offset ~S is too big.", 1, vs_base[0]);
}
vs_base[0] = l->c.c_car;
vs_pop;
}
init_structure_function()
{
siSstructure_print_function
= make_si_ordinary("STRUCTURE-PRINT-FUNCTION");
enter_mark_origin(&siSstructure_print_function);
siSstructure_slot_descriptions
= make_si_ordinary("STRUCTURE-SLOT-DESCRIPTIONS");
enter_mark_origin(&siSstructure_slot_descriptions);
siSstructure_include = make_si_ordinary("STRUCTURE-INCLUDE");
enter_mark_origin(&siSstructure_include);
make_si_function("MAKE-STRUCTURE", siLmake_structure);
make_si_function("COPY-STRUCTURE", siLcopy_structure);
make_si_function("STRUCTURE-NAME", siLstructure_name);
make_si_function("STRUCTURE-REF", siLstructure_ref);
make_si_function("STRUCTURE-SET", siLstructure_set);
make_si_function("STRUCTUREP", siLstructurep);
make_si_function("RPLACA-NTHCDR", siLrplaca_nthcdr);
make_si_function("LIST-NTH", siLlist_nth);
}